{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE OverlappingInstances   #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Dependencies.Term2tree
-- Copyright   :  (c) 2009--2010 TU Dortmund
-- License     :  BSD3
--
-- Maintainer  :  menge@udo.cs.uni-dortmund.de
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Provides a data-type generic function to build a rose tree of constructor 
-- names representing any AST.
-----------------------------------------------------------------------------

module Language.Dependencies.Term2tree (data2tree) where

import Generics.MultiRec.Base
import Generics.MultiRec.HFunctor
import Generics.MultiRec.Constructor
import Generics.MultiRec.TH
import qualified Data.Tree as DT
import Data.Traversable


-- | Main interface, along the lines of "from" and "to". Provide a 
--   type-rep and a term and get a "Tree String"
data2tree :: forall phi ix. (Fam phi, Data2Tree phi (PF phi)) 
          => phi ix -> ix -> DT.Tree String
data2tree p = tree2tree . data2tree' p


-- | simpler trees
data Tree = Node String [Tree] deriving (Show)

-- | convert simple trees to Data.Tree
tree2tree :: Tree -> DT.Tree String
tree2tree (Node s ts) = DT.Node s (map tree2tree ts)

-- | Worker function that calls hData2Tree and simply 
--   extracts the only root of the term.
data2tree' :: forall phi ix. (Fam phi, Data2Tree phi (PF phi)) 
           => phi ix -> ix -> Tree
data2tree' p x = head $ hData2Tree p (\p' (I0 x') -> [data2tree' p' x']) (from p x)

-- | Provides the "generic" interface to the generic function. Below, we 
--   provide an instance for any possible base functor.
class Data2Tree (phi :: * -> *) (f :: (* -> *) -> * -> *) where
  hData2Tree :: phi ix -> (forall ix. phi ix -> r ix -> [Tree]) -> f r ix -> [Tree]

instance (Constructor c, Data2Tree phi f) => Data2Tree phi (C c f) where
  hData2Tree p r cx@(C f) = [Node (conName cx) (hData2Tree p r f)]

instance (Data2Tree phi f, Data2Tree phi g) => Data2Tree phi (f :+: g) where
  hData2Tree p r (L f) = hData2Tree p r f
  hData2Tree p r (R f) = hData2Tree p r f

instance (Show x) => Data2Tree phi (K x) where
  hData2Tree _ _ (K x) = [Node (show x) []]
  
instance Data2Tree phi (K String) where
  hData2Tree _ _ (K s) = [Node s []]

instance Data2Tree phi U where
  hData2Tree _ _ _ = []

instance (Data2Tree phi f, Data2Tree phi g) => Data2Tree phi (f :*: g) where
  hData2Tree p r (f :*: g) = hData2Tree p r f ++ hData2Tree p r g

instance (El phi ix) => Data2Tree phi (I ix) where
  hData2Tree p r (I x) = r proof x

instance (Data2Tree phi f, Show ix) => Data2Tree phi (f :>: ix) where
  hData2Tree p r (Tag f) = hData2Tree p r f
